perm filename POLYA[PAT,LMM] blob
sn#099907 filedate 1974-04-29 generic text, type T, neo UTF8
(FILECREATED "29-APR-74 03:10:09" POLYA 6633
changes to: POLYAFNS)
(DEFINEQ
(POLYA
[LAMBDA (NODES GROUP SUBLIST)
(* Args are the same as to MANYLABELGRAPH ;
however POLYA returns the number of labellings rather than
the actual labellings. Evaluates G.
POLYA's function for the number of double cosets of two
groups under SN -
METHOD: reset GROUP to a composition list of cycle indices;
th identity needs to be filled in;
the function PERMCYCLEINDEX1 given a PERMUTATION returns a
list of the sizes of the CYCLES of the perm, but CYCLES of
SIZE one are not included; note also that each PERMUTATION
in the original GROUP stands for 2*{LENGTH PERM:ORDER}
permutations unless ORDER is NIL, in which case it stands
for only one PERMUTATION. To compute the coeficient of
x1↑n1* x2↑n2*...Xk↑nk in the polynomial -
(sum for P in GROUP (product for C a cycle of P
(x1↑|c|+x2↑|c|...+xk↑|c|)) SUBLIST is
(n1 n2 ,,, nk) and NEWGROUP is the polynomial with
redundancies in the sum and product eliminated by using
composition lists))
(PROG [D C NEWGROUP (SUBLIST (LFROMCL SUBLIST (SETSIZE NODES]
(SETQ C (for PERM in (SETQ NEWGROUP (CYCLEINDEX GROUP NODES))
sum (CDR PERM)))
L1 [COND
((NULL (CDR SUBLIST))
(RETURN (IQUOTIENT (for X in NEWGROUP sum (CDR X))
C]
(SETQ GROUP NEWGROUP)
(SETQ NEWGROUP NIL)
[for X in GROUP
do (for S in (SUBSETS (CAR X)
(CAR SUBLIST))
do (SETQ NEWGROUP (INSERTCL (ITIMES (CDR X)
(CDR S))
(DIFFCL (CAR X)
(CAR S))
NEWGROUP
(FUNCTION (LAMBDA (X Y)
(AND (NOT (EQUAL X Y))
(ORDERED X Y]
(SETQ SUBLIST (CDR SUBLIST))
(GO L1])
(LFROMCL
[LAMBDA (CL N)
(SETQ CL (SORT (MAPCAR CL (QUOTE CDR))
(QUOTE ILESSP)))
(COND
([NOT (ZEROP (SETQ N (IDIFFERENCE N (sum X for X in CL]
(INSERT N CL (QUOTE ILESSP)))
(T CL])
(SETSIZE
[LAMBDA (X)
(ADD1 (WHILE [NOT (EMPTY (SETQ X (REST X] SUM 1])
(REST
[LAMBDA (X)
(LOGAND X (SUB1 X])
(INSERT
[LAMBDA (ITEM LST CMPR)
(COND
((OR (NULL LST)
(APPLY* CMPR ITEM (CAR LST)))
(CONS ITEM LST))
(T (FRPLACD LST (INSERT ITEM (CDR LST)
CMPR])
(CYCLEINDEX
[LAMBDA (GROUP NODES)
(PROG (INDEX)
[for PERM in GROUP do (SETQ INDEX
(INSERTCL 1 (PCYCLEINDEX (fetch CYCLES
of PERM)
NODES)
INDEX
(FUNCTION (LAMBDA (X Y)
(AND (NOT (EQUAL X Y))
(ORDERED X Y]
(RETURN (CONS (CONS (LIST (CONS 1 (SETSIZE NODES)))
1)
INDEX])
(PCYCLEINDEX
[LAMBDA (CYCLES NODES)
(PROG (INDEX)
[for CYCLE in CYCLES do (SETQ INDEX (INSERTCL 1 (SETSIZE
(INTERSECT CYCLE
NODES))
INDEX
(QUOTE ILESSP]
(RETURN (COND
([NOT (EQP 0 (SETQ CYCLES
(IDIFFERENCE (SETSIZE NODES)
(for X in INDEX
sum (ITIMES (CAR X)
(CDR X]
(CONS (CONS 1 CYCLES)
INDEX))
(T INDEX])
(SUBSETS
[LAMBDA (C N)
(* C is a composition list of numbers.
-
N a number -
Value a list of dotted pairs ;the CAR of each is a
subcollection of C such that the elements of that
subcollection add up to N ;the CDR is the number of ways
that subcollection can be formed from the l's if the l's
were all different -
E,g, SUBSETS (((5 . 1) (4 . 2)
(1 . 1)) 5) yields (((5 . 1)) . 1)
(((4 . 1) (1 . 1)) . 2) since 5 can be obtained by taking
one 5 in one way ;or by taking a four and a one in two
different ways;)
(COND
[(EQ 0 N)
(QUOTE ((NIL . 1]
((on old C always (IGREATERP (CAAR C)
N))
NIL)
(T
(* get rid of numbers at head that are too big;
return NIL when they are all to big;
the first of the list is all subsets without using the first
of C)
(* the first element of the new subset is the first of the
old; try up to how many on the old;
I is the number of times it occurs and II is the amount
taken; IT is upper-bounded by N.
Try every subset of the reset adding up to N-II.)
(* X must not be NIL; the factor is the number of ways of
taking I elements out of the (CDAR C) element available)
(for I from 1 to (CDAR C) as II from (CAAR C) to N
by (CAAR C) bind X FACTOR
join (AND (SETQ X (SUBSETS (CDR C)
(IDIFFERENCE N II)))
(SETQ FACTOR (TAKEN (CDAR C)
I))
(NCONC [on old X
rcollect (CONS (CONS (CONS (CAAR C)
I)
(CAAR X))
(ITIMES FACTOR (CDAR X]
(SUBSETS (CDR C)
N])
(TAKEN
[LAMBDA (N I)
(bind RESULT←1 for J from 1 to I do (SETQ RESULT (IQUOTIENT (ITIMES RESULT
N)
J))
(SETQ N (SUB1 N))
finally (RETURN RESULT])
(DIFFCL
[LAMBDA (L1 L2)
(* L1, L2 are two composition lists -
Val the (set) difference (L1-L2))
(for X in L1 bind N
when (IGREATERP (SETQ N (IDIFFERENCE (CDR X)
(OR (CDR (SASSOC (CAR X)
L2))
0)))
0)
collect (CONS (CAR X)
N])
)
(LISPXPRINT (QUOTE POLYAFNS)
T)
(RPAQQ POLYAFNS (POLYA LFROMCL SETSIZE REST INSERT CYCLEINDEX PCYCLEINDEX
ORDERED SUBSETS TAKEN DIFFCL))
(LISPXPRINT (QUOTE POLYAVARS)
T)
(RPAQQ POLYAVARS ((PROP MACRO SETSIZE REST SETSIZE)))
(DEFLIST(QUOTE(
[SETSIZE ((A)
(LOC (ASSEMBLE NIL (CQ (VAG A))
(MOVE 2 , 1)
(HRRZI 1 , 0)
(JUMPE 2 , RET)
LP
(ADDI 1 , 1)
(MOVE 3 , 2)
(SUBI 3 , 1)
(AND 2 , 3)
(JUMPN 2 , LP)
RET]
[REST ((X)
(LOC (ASSEMBLE NIL (CQ (VAG X))
(HRREI 2 , -1)
(ADD 2 , 1)
(AND 1 , 2]
[SETSIZE ((A)
(LOC (ASSEMBLE NIL (CQ (VAG A))
(MOVE 2 , 1)
(HRRZI 1 , 0)
(JUMPE 2 , RET)
LP
(ADDI 1 , 1)
(MOVE 3 , 2)
(SUBI 3 , 1)
(AND 2 , 3)
(JUMPN 2 , LP)
RET]
))(QUOTE MACRO))
(PROGN (QUOTE JUSTEVALUATE)
(FILEMAP (NIL (83 5723 (POLYA 95 . 1997) (LFROMCL 2001 . 2215) (SETSIZE 2219
. 2297) (REST 2301 . 2346) (INSERT 2350 . 2535) (CYCLEINDEX 2539 . 2920) (
PCYCLEINDEX 2924 . 3371) (ORDERED 3375 . 3371) (SUBSETS 3375 . 5201) (TAKEN
5205 . 5392) (DIFFCL 5396 . 5720)))))
STOP